COMMENT ⊗   VALID 00010 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	% This program by D. E. Knuth is not copyrighted and can be used freely.
C00004 00003	@* Introduction.
C00010 00004	@* Random numbers.
C00013 00005	@* The character set.
C00018 00006	@* Basic input.
C00025 00007	@* Cards.
C00028 00008	@* Monte Carlo backtracking.
C00038 00009	@* The main program.
C00047 00010	@* Index.
C00058 ENDMK
C⊗;
% This program by D. E. Knuth is not copyrighted and can be used freely.

% Here is TeX material that gets inserted after \input webmac
\def\title{SOLIT}
\magnify{\magstep1}
%\pagewidth=4.2truein % estimate to match CACM line length
\setpage
%\tolerance=1000
\font\tenlogo=logo10 % font used for the METAFONT logo
\def\MF{{\tenlogo META}\-{\tenlogo FONT}}

%\advance\topskip by \baselineskip	% doublespacing
%\advance\smallskipamount by \baselineskip
%\advance\baselineskip by \baselineskip
@* Introduction.
[This program was written while I was fiddling with problem~1.]

@ Here are some macros I may use for terminal I/O.

@d read_terminal(#)==read(tty,#) {input a value from the terminal}
@d print(#)==write(tty,#) {output to the terminal}
@d print_ln(#)==write_ln(tty,#) {output to the terminal and end the line}

@ Here's an outline of the entire Pascal program:

@p @t\4@>@<Compiler directives@>@/
program solit;
label @<Labels in the outer block@>@/
const @<Constants in the outer block@>@/
type @<Types in the outer block@>@/
var@?@<Global variables@>@/
@#
procedure initialize; {this procedure gets things started properly}
	var @!i:integer; {all-purpose index for initialization}
	begin @<Set initial values@>@;
	end;@#
@t\2\4@>@<Random procedures@>@;
@<I/O procedures@>@;
@<Special procedures@>@;
begin initialize; @<The main program@>;
end.

@ Blah blah about constants.

@<Constants in the outer block@>=
buf_size=80; {maximum line length}
max_m=10; {maximum number of rows, plus~1}
max_n=21; {maximum number of columns, plus~1}

@ The only label needed in the main program is |final_end|.

@d final_end=9999 {this label marks the ending of the program}

@<Labels in the out...@>=
final_end;

@ If the first character of a Pascal comment is a dollar sign, the
compiler used here treats the comment as a list of ``compiler directives''
that will affect the translation of this program into machine language.

@<Compiler directives@>=
@{@&$C+,A+,D+@} {yes range check, catch arithmetic overflow, yes debug overhead}

@ We assume that |case| statements may include a
default case that applies if no matching label is found.

@d othercases == others: {default for cases not listed explicitly}
@d endcases == @+end {follows the default case in an extended |case| statement}
@f othercases == else
@f endcases == end

@ Labels are given symbolic names by the following definitions, copied from
the program for \TeX. This program doesn't actually use all the conventions
defined here; they are provided just to make changes easier.

@d exit=10 {go here to leave a procedure}
@d restart=20 {go here to start a procedure again}
@d reswitch=21 {go here to start a case statement again}
@d continue1=22 {go here to resume a loop}
@d continue2=23 {go here to resume a loop}
@d done=30 {go here to exit a loop}
@d done1=31 {like |done|, when there is more than one loop}
@d done2=32 {for exiting the second loop in a long block}
@d done3=33 {for exiting the third loop in a very long block}
@d done4=34 {for exiting the fourth loop in an extremely long block}
@d done5=35 {for exiting the fifth loop in an immense block}
@d done6=36 {for exiting the sixth loop in a block}
@d found=40 {go here when you've found it}
@d found1=41 {like |found|, when there's more than one per routine}
@d found2=42 {like |found|, when there's more than two per routine}
@d not_found=45 {go here when you've found nothing}
@d common_ending=50 {go here when you want to merge with another branch}

@ Here are some macros for common programming idioms.

@d incr(#) == #←#+1 {increase a variable by unity}
@d decr(#) == #←#-1 {decrease a variable by unity}
@d negate(#) == #←-# {change the sign of a variable}
@d loop == @+ while true do@+ {repeat over and over until a |goto| happens}
@f loop == xclause
	{\.{WEB}'s |xclause| acts like `\ignorespaces|while true do|\unskip'}
@d do_nothing == {empty statement}
@d return == goto exit {terminate a procedure call}
@f return == nil
@* Random numbers.
Here are some procedures for random number generation copied from
\MF\ with minor changes.

There's an auxiliary array |randoms| that contains 55 pseudo-random
fractions. Using the recurrence $x_n=(x_{n-55}-x_{n-31})\bmod \\{rbase}$,
we generate batches of 55 new $x_n$'s at a time by calling |new_randoms|.
The global variable |j_random| tells which element has most recently
been consumed.

@d rbase==1000000000 {range of random numbers}
@d half_rbase==500000000

@<Glob...@>=
@!randoms:array[0..54] of 0..rbase-1; {the last 55 random values generated}
@!j_random:0..54; {the number of unused |randoms|}

@ @d access_rand==if j_random=0 then new_randoms
	else decr(j_random)

@<Random...@>=
procedure new_randoms;
var @!k:0..54; {index into |randoms|}
@!x:integer; {accumulator}
begin for k←0 to 23 do
	begin x←randoms[k]-randoms[k+31];
	if x<0 then x←x+rbase;
	randoms[k]←x;
	end;
for k←24 to 54 do
	begin x←randoms[k]-randoms[k-24];
	if x<0 then x←x+rbase;
	randoms[k]←x;
	end;
j_random←54;
end;

@ To initialize the |randoms| table, we call the following routine.

@<Random...@>=
procedure init_randoms(@!seed:integer);
var @!j,@!jj,@!k:integer; {more or less random integers}
@!i:0..54; {index into |randoms|}
begin j←abs(seed);
while j≥rbase do j←j div 2;
k←1;
for i←0 to 54 do
	begin jj←k; k←j-k; j←jj;
	if k<0 then k←k+rbase;
	randoms[(i*21)mod 55]←j;
	end;
new_randoms; new_randoms; new_randoms; {``warm up'' the array}
end;
@* The character set.
We need translation tables between ASCII and the actual character
set, in order to make this program portable. The standard conventions of
{\sl \TeX: The Program\/} are copied here, essentially verbatim.

@d text_char == char {the data type of characters in text files}
@d first_text_char=0 {ordinal number of the smallest element of |text_char|}
@d last_text_char=127 {ordinal number of the largest element of |text_char|}

@<Types...@>=
@!ASCII_code=0..127; {seven-bit numbers}

@ @<Glob...@>=
@!xord: array [text_char] of ASCII_code;
	{specifies conversion of input characters}
@!xchr: array [ASCII_code] of text_char;
	{specifies conversion of output characters}

@ @<Set init...@>=
xchr[@'40]←' ';
xchr[@'41]←'!';
xchr[@'42]←'"';
xchr[@'43]←'#';
xchr[@'44]←'$';
xchr[@'45]←'%';
xchr[@'46]←'&';
xchr[@'47]←'''';@/
xchr[@'50]←'(';
xchr[@'51]←')';
xchr[@'52]←'*';
xchr[@'53]←'+';
xchr[@'54]←',';
xchr[@'55]←'-';
xchr[@'56]←'.';
xchr[@'57]←'/';@/
xchr[@'60]←'0';
xchr[@'61]←'1';
xchr[@'62]←'2';
xchr[@'63]←'3';
xchr[@'64]←'4';
xchr[@'65]←'5';
xchr[@'66]←'6';
xchr[@'67]←'7';@/
xchr[@'70]←'8';
xchr[@'71]←'9';
xchr[@'72]←':';
xchr[@'73]←';';
xchr[@'74]←'<';
xchr[@'75]←'=';
xchr[@'76]←'>';
xchr[@'77]←'?';@/
xchr[@'100]←'@@';
xchr[@'101]←'A';
xchr[@'102]←'B';
xchr[@'103]←'C';
xchr[@'104]←'D';
xchr[@'105]←'E';
xchr[@'106]←'F';
xchr[@'107]←'G';@/
xchr[@'110]←'H';
xchr[@'111]←'I';
xchr[@'112]←'J';
xchr[@'113]←'K';
xchr[@'114]←'L';
xchr[@'115]←'M';
xchr[@'116]←'N';
xchr[@'117]←'O';@/
xchr[@'120]←'P';
xchr[@'121]←'Q';
xchr[@'122]←'R';
xchr[@'123]←'S';
xchr[@'124]←'T';
xchr[@'125]←'U';
xchr[@'126]←'V';
xchr[@'127]←'W';@/
xchr[@'130]←'X';
xchr[@'131]←'Y';
xchr[@'132]←'Z';
xchr[@'133]←'[';
xchr[@'134]←'\';
xchr[@'135]←']';
xchr[@'136]←'↑';
xchr[@'137]←'_';@/
xchr[@'140]←'`';
xchr[@'141]←'a';
xchr[@'142]←'b';
xchr[@'143]←'c';
xchr[@'144]←'d';
xchr[@'145]←'e';
xchr[@'146]←'f';
xchr[@'147]←'g';@/
xchr[@'150]←'h';
xchr[@'151]←'i';
xchr[@'152]←'j';
xchr[@'153]←'k';
xchr[@'154]←'l';
xchr[@'155]←'m';
xchr[@'156]←'n';
xchr[@'157]←'o';@/
xchr[@'160]←'p';
xchr[@'161]←'q';
xchr[@'162]←'r';
xchr[@'163]←'s';
xchr[@'164]←'t';
xchr[@'165]←'u';
xchr[@'166]←'v';
xchr[@'167]←'w';@/
xchr[@'170]←'x';
xchr[@'171]←'y';
xchr[@'172]←'z';
xchr[@'173]←'{';
xchr[@'174]←'|';
xchr[@'175]←'}';
xchr[@'176]←'~';@/
xchr[0]←' '; xchr[@'177]←' ';
	{ASCII codes 0 and |@'177| do not appear in text}

@ Some of the ASCII codes without visible characters have been given symbolic
names in this program because they are used with a special meaning.

@d null_code=@'0 {ASCII code that might disappear}
@d carriage_return=@'15 {ASCII code used at end of line}
@d invalid_code=@'177 {ASCII code that should not appear}

@<Set init...@>=
for i←1 to @'37 do xchr[i]←chr(i);
for i←first_text_char to last_text_char do xord[chr(i)]←invalid_code;
for i←1 to @'176 do xord[xchr[i]]←i;
@* Basic input.
Input goes into an array called |buffer|, in a machine-independent form.
If anything goes wrong during an input process, the variable |input_awry|
is set |true| and an error message is printed.

@<Glob...@>=
@!buffer: array[0..buf_size] of ASCII_code; {the current line of input}
@!input_awry: boolean; {has something gone wrong?}

@ Values are read from the buffer by various scanning routines
whose names begin with `\\{get}'. They use the global variable |loc|
to find the current buffer position, as well as the global variable |limit|
which is the smallest unused buffer location.

@<Glob...@>=
@!loc:0..buf_size; {the next character to read is in |buffer[loc]|}
@!limit:0..buf_size; {but if |loc=limit|, the line has been fully read}

@ @<Set init...@>=
input_awry←false; loc←0; limit←0;

@ Here's a procedure that shows the current buffer contents,
using two lines to indicate how many of the characters have been scanned.
It is used only in error messages.

@d input_err(#)==begin print_ln(#,'!'); print_buf; input_awry←true;@+end

@<I/O procedures@>=
procedure print_buf;
var @!k:0..buf_size;
begin if loc>0 then for k←0 to loc-1 do print(xchr[buffer[k]]);
print_ln('');
if loc>0 then for k←0 to loc-1 do print(' ');
if loc<limit then for k←loc to limit-1 do print(xchr[buffer[k]]);
print_ln('');
end;

@ Files are assumed to consist of text only.

@<Types...@>=
@!text_file=packed file of text_char;

@ Input data will be read from |data_file|, which we assume can be
opened by specifying the file name dynamically.
@↑system dependencies@>

@d open_data_file(#)==reset(data_file,#)

@<Glob...@>=
@!data_file:text_file;

@ When all input has been performed on |data_file|, we call `|close_data_file|',
a routine that releases the file for use by others (if our version of
Pascal allows this).
@↑system dependencies@>

@d close_data_file==close(data_file)

@ The |input_ln| procedure brings the next line of input from the
specified file into the |buffer| array. The conventions of \TeX\ are
followed; i.e., |ASCII_code| numbers representing the next line of the
file are input into |buffer[0]|, |buffer[1]|, \dots, |buffer[limit-1]|, and
trailing blanks are ignored. The global variable |limit| is set to the
length of the line, and |loc| is cleared to zero.
The character `\.?' is placed at the end of the line, in case some
scanning routine fetches |buffer[loc]|.

The file should not have ended when |input_ln| is called.
@↑system dependencies@>

@<I/O procedures@>=
procedure input_ln(var@!f:text_file;@!bypass_eoln:boolean); {inputs a line}
var @!final_limit:0..buf_size; {|limit| without trailing blanks}
begin if bypass_eoln then if not eof(f) then get(f);
if eof(f) then input_err('Unexpected end of file')
@.Unexpected end of file@>
else	begin limit←0; final_limit←0; loc←0;
	while not eoln(f) do
		begin buffer[limit]←xord[f↑]; get(f);
		incr(limit);
		if buffer[limit-1]≠" " then final_limit←limit;
		if limit=buf_size then
			begin input_err('Input line too long');
@.Input line too long@>
			while not eoln(f) do get(f);
			end;
		end;
	limit←final_limit; buffer[limit]←"?";
	end;
end;

@ Here's the simplest scanning routine: It returns a single character,
in ASCII code.

@<I/O proc...@>+=
function get_char:ASCII_code;
var @!c:ASCII_code; {the character to return}
begin c←buffer[loc];
if loc<limit then incr(loc)@+else input_err('Input line too short');
@.Input line too short@>
get_char←c;
end;

@ The next simplest scanning routine returns an integer value.

@<I/O proc...@>=
function get_int:integer;
var @!x:integer; {the number to return}
@!loc0:0..buf_size; {initial |loc| setting}
begin loc0←loc; x←0;
while (buffer[loc]≥"0")∧(buffer[loc]≤"9") do
	begin x←10*x+buffer[loc]-"0"; incr(loc);
	end;
if loc=loc0 then input_err('Missing integer');
@.Missing integer@>
get_int←x;
end;
@* Cards.
Playing cards are represented by the integers |0..51|. We decode them in
the ``obvious'' way.

@<Glob...@>=
@!rank:array[0..12] of ASCII_code;
@!suit:array[0..3] of ASCII_code;

@ @<Types...@>=
@!card=0..51;

@ @<Set init...@>=
rank[0]←"A"; rank[1]←"2"; rank[2]←"3"; rank[3]←"4"; rank[4]←"5";
rank[5]←"6"; rank[6]←"7"; rank[7]←"8"; rank[8]←"9"; rank[9]←"T";
rank[10]←"J"; rank[11]←"Q"; rank[12]←"K";@/
suit[0]←"C"; suit[1]←"D"; suit[2]←"H"; suit[3]←"S";

@ @<I/O...@>=
procedure print_card(@!x:card);
begin print(xchr[rank[x mod 13]]); print(xchr[suit[x div 13]]);
end;

@ The function |read_cards| returns |false| if any anomaly is detected.

@<I/O...@>= 
function read_cards:boolean;
label not_found,found,exit;
var i,x:integer;
begin if data_begun then input_ln(data_file,true)
else	begin input_ln(data_file,false); data_begun←true;
	end;
for i←1 to 18 do
	begin if input_awry then goto not_found;
	case get_char of
	"A":x←0;
	"2":x←1;
	"3":x←2;
	"4":x←3;
	"5":x←4;
	"6":x←5;
	"7":x←6;
	"8":x←7;
	"9":x←8;
	"T":x←9;
	"J":x←10;
	"Q":x←11;
	"K":x←12;
	othercases input_err('Bad rank')
	endcases;
	if input_awry then goto not_found;
	case get_char of
	"C":init_cards[i]←x;
	"D":init_cards[i]←x+13;
	"H":init_cards[i]←x+26;
	"S":init_cards[i]←x+39;
	othercases input_err('Bad suit')
	endcases;
	end;
found: read_cards←true; return;
not_found: read_cards←false;
exit:
end;

@ @<Glob...@>=
@!data_begun:boolean; {have we read the first line of the file?}

@ @<Set init...@>=
data_begun←false;
@* Monte Carlo backtracking.
I'm trying Pang Chen's method of estimation. The basic data structure
is a three-dimensional array, with two dimensions for the stratum
(level and mobility) and one for the current ``board.''
Auxiliary arrays with heuristic and control information are also provided.

@<Glob...@>=
@!board:array[1..18,0..32,1..18] of card;
@!weight:array[1..18,0..32] of integer;
@!cutoff:array[1..18,0..32] of 1..18;
@!cards,@!init_cards:array[1..18] of card;
@!source:array[1..18,0..32] of integer;
@!counts,@!escapes:array[1..18,0..32,0..3] of integer;

@ First I need a simple procedure to calculate mobility.

@<Special pro...@>=
function mobility(@!n,@!c:integer):integer;
var i,x:integer;
begin x←0;
for i←c to n do
	begin if i>1 then
		begin if cards[i] mod 13=cards[i-1] mod 13 then incr(x)
		else if cards[i] div 13=cards[i-1] div 13 then incr(x);
		end;
	if i>3 then
		begin if cards[i] mod 13=cards[i-3] mod 13 then incr(x)
		else if cards[i] div 13=cards[i-3] div 13 then incr(x);
		end;
	end;
mobility←1;
end;

@ And here's a routine that figures out how a victory was made.

@ @<Special pro...@>=
procedure win(n,m:integer);
var nn,mm,c:integer;
begin if not victory then
	begin victory←true;
	if victories=0 then
		begin print_ln('Here''s a win!');
		while n<18 do
			begin nn←source[n,m] div 1000; mm←source[n,m] mod 1000;
			c←cutoff[n,m]; print(' '); print_card(board[n,m,c]);
			if board[nn,mm,c+1]=board[n,m,c] then print(' x ') else print(' xx ');
			print_card(board[nn,mm,c]); print_ln('');
			n←nn; m←mm;
			end;
		end;
	incr(victories);
	end;
end;

@ @<Glob...@>=
@!victory:boolean;
@!victories:integer;

@ @<Special pro...@>=
function pang:integer;
label done,done1,done2,continue1,continue2;
var i,j,ii,m,mm,n,nn,c,w,ww,old_card,tot_wt:integer;
d,s,rank,suit:integer;
begin victory←false;
@<Set up the root of the tree and clear the other weights@>;
for n←18 downto 2 do for m←32 downto 0 do
	begin w←weight[n,m];
	if w>0 then @<Expand position |[i,m]|@>;
	end;
pang←tot_wt;
end;

@ @<Set up the root...@>=
for i←1 to 18 do cards[i]←init_cards[i];
for n←1 to 18 do for m←0 to 32 do weight[n,m]←0;
m←mobility(18,1); cutoff[18,m]←1; weight[18,m]←1; source[18,m]←0;
for i←1 to 18 do board[18,m,i]←cards[i];
tot_wt←1

@ @<Expand...@>=
begin tot_wt←tot_wt+w;
if m>0 then
	begin for i←1 to n do cards[i]←board[n,m,i]; c←cutoff[n,m];
	nn←source[n,m] div 1000; mm←source[n,m] mod 1000;
	@{@<Print info about the position being expanded@>;@}
	@<Go to |done| if the game is obviously won or lost@>;
	nn←n-1;
	for i←c to n do
		begin if i>1 then
			begin ii←i-1;
			if cards[i] mod 13≠cards[ii] mod 13 then
			 if cards[i] div 13 ≠ cards[ii] div 13 then goto done1;
			@<Take and unmove@>;
			end;
		done1: if i>3 then
			begin ii←i-3;
			if cards[i] mod 13≠cards[ii] mod 13 then
			 if cards[i] div 13 ≠ cards[ii] div 13 then goto done2;
			@<Double take and unmove@>;
			end;
		done2:end;
	done:end;
end

@ @<Go to...@>=
if n=18 then @<Initialize the |counts| and |escapes|@>
else	begin for suit←0 to 3 do
		begin counts[n,m,suit]←counts[nn,mm,suit];
		escapes[n,m,suit]←escapes[nn,mm,suit];
		end;
	old_card←board[nn,mm,c]; rank←old_card mod 13; suit←old_card div 13;
	decr(counts[n,m,suit]);
	for i←1 to n do if cards[i] mod 13=rank then
		begin d←escapes[n,m,suit]-1; escapes[n,m,suit]←d;
		if d=0 then if counts[n,m,suit]>0 then
			begin if counts[n,m,suit]=n then win(n,m)
			else @{print_ln('LOST!')@};
			goto done;
			end;
		s←cards[i] div 13; d←escapes[n,m,s]-1; escapes[n,m,s]←d;
		if d=0 then
			begin if counts[n,m,s]=n then win(n,m)
			else @{print_ln(' LOST!')@};
			goto done;
			end;
		end;
	end;
@{print(' counts'); for suit←0 to 3 do print(' ',counts[n,m,suit]:1);
print(', escapes'); for suit←0 to 3 do print(' ',escapes[n,m,suit]:1);
print_ln('')@}

@ @<Initialize the |counts|...@>=
begin for suit←0 to 3 do
	begin counts[n,m,suit]←0; escapes[n,m,suit]←0;
	end;
for i←1 to n do
	begin rank←cards[i] mod 13; suit←cards[i] div 13; incr(counts[n,m,suit]);
	for ii←1 to i-1 do if cards[ii] mod 13 =rank then
		begin incr(escapes[n,m,cards[ii] div 13]); incr(escapes[n,m,suit]);
		end;
	end;
end

@ @<Take and unmove@>=
old_card←cards[ii]; cards[ii]←cards[i];
for j←i to nn do cards[j]←cards[j+1];
mm←mobility(nn,ii);
@{@<Print info about this move@>;@}
ww←weight[nn,mm]; weight[nn,mm]←w+ww;
if ww>0 then 
	begin access_rand;
	if randoms[j_random] mod(w+ww)≥w then goto continue1;
	end;
@{print_ln('  (Chosen, with probability ',w:1,'/',w+ww:1,')');@}
for j←1 to nn do board[nn,mm,j]←cards[j];
cutoff[nn,mm]←ii; source[nn,mm]←1000*n+m;
continue1: for j←nn downto i do cards[j+1]←cards[j];
cards[i]←cards[ii]; cards[ii]←old_card

@ @<Double take and unmove@>=
old_card←cards[ii]; cards[ii]←cards[i];
for j←i to nn do cards[j]←cards[j+1];
mm←mobility(nn,ii);
@{@<Print info about this move@>;@}
ww←weight[nn,mm]; weight[nn,mm]←w+ww;
if ww>0 then 
	begin access_rand;
	if randoms[j_random] mod(w+ww)≥w then goto continue2;
	end;
@{print_ln('  (Chosen, with probability ',w:1,'/',w+ww:1,')');@}
for j←1 to nn do board[nn,mm,j]←cards[j];
cutoff[nn,mm]←ii; source[nn,mm]←1000*n+m;
continue2: for j←nn downto i do cards[j+1]←cards[j];
cards[i]←cards[ii]; cards[ii]←old_card

@ @<Print info about this move@>=
print('  '); print_card(cards[ii]);
if ii=i-1 then print(' x ')@+else print(' xx ');
print_card(old_card);
print_ln(', mobility is ',mm:1)

@ @<Print info about the position being expanded@>=
print('Expanding (',n:1,',',m:1,'), weight ',w:1,': ');
for j←1 to n do
	begin if j=c then print('|')@+else print(' ');
	print_card(cards[j]);
	end;
print_ln(' [from ',nn:1,',',mm:1,']')
@* The main program.
(temporary, I keep hacking at this)

@<The main...@>=
open_data_file('SHUFF.DAT'); round←0;
while read_cards do
	begin incr(round); print(round:1,', ');
	for i←1 to 18 do
		begin print_card(init_cards[i]); print(' ');
		end;
	print_ln(':'); acc←0; victories←0;
	for i←201 to 205 do
		begin init_randoms(i);
		p←pang; print('[',p:1,']');
		acc←acc+p;
		end;
	print_ln('*** Total size estimate = ',acc/5:5:2,'; ',
		victories:1,' wins');
	end;
final_end: close_data_file;

@ @<Glob...@>=
@!p:integer;
@!i:integer;
@!acc:integer;
@!round:integer;
@* Index.
Here are the quantities declared and/or used in the program.
(The uses of single-letter variables aren't indexed.)